home *** CD-ROM | disk | FTP | other *** search
/ TeX 1995 July / TeX CD-ROM July 1995 (Disc 1)(Walnut Creek)(1995).ISO / macros / latex209 / contrib / slatex / rnrscl.cl < prev    next >
Lisp/Scheme  |  1993-11-07  |  8KB  |  406 lines
  1. ;rnrscl.cl
  2. ;almost (but not quite!) simulates rnrs scheme in cl
  3. ;(c) Dorai Sitaram, December 1991, Rice University
  4.  
  5. ;first make lambdas and applications Scheme-like
  6. ;by loading funval.cl
  7. ;i.e., no funcalls or #'s should be needed ever
  8.  
  9. ;defining rnrs procedures and forms
  10.  
  11. (eval-when (compile load eval)
  12.   ;the following names could clash
  13.   (shadow '(assoc let loop make-string map member nil peek-char read 
  14.          read-char rem string t write)))
  15.  
  16. (defmacro set! (x v) `(setq ,x ,v))
  17.  
  18. (defmacro begin z `(progn ,@z))
  19.  
  20. (begin
  21.   ;the boolean constants #t and #f
  22.   (set-dispatch-macro-character #\# #\t
  23.     (lambda (ign1 ign2 ign3) lisp:t))
  24.   (set-dispatch-macro-character #\# #\f
  25.     (lambda (ign1 ign2 ign3) lisp:nil))
  26.   ;t and nil are now ordinary variables
  27.   (set! t lisp:t)
  28.   (set! nil lisp:nil)) 
  29.  
  30. (defconstant else
  31.   ;for cond else clause
  32.   #t)
  33.  
  34. (define map mapcar)
  35.  
  36. ;eq?
  37.  
  38. (define eq? eq)
  39.  
  40. ;boolean?
  41.  
  42. (define boolean?
  43.   (lambda (b)
  44.     (or (eq? b #t) (eq? b #f))))
  45.  
  46. ;symbol?
  47.  
  48. (define symbol?
  49.   (lambda (x)
  50.     ;like symbolp but scheme doesn't consider booleans to be symbols
  51.     (and (symbolp x) (not (boolean? x))))) 
  52.  
  53. ;symbol->string
  54.  
  55. (define symbol->string symbol-name)
  56.  
  57. ;char-ci=?
  58.  
  59. (define char-ci=? char-equal)
  60.  
  61. ;string-ref
  62.  
  63. (define string-ref char)
  64.  
  65. ;letrec
  66.  
  67. (defmacro letrec (pp . b)
  68.   `(lisp:let ,(map (lambda (p) `(,(car p) 'void))
  69.         pp)
  70.      ,@(map (lambda (p)
  71.          `(set! ,(car p) ,(cadr p)))
  72.      pp)
  73.      ,@b))
  74.  
  75. ;named let with special treatment of loops (use variables with
  76. ;names beginning with 'loop only when you're sure that you're
  77. ;making calls to the named let proc only from tail positions).
  78.  
  79. (defmacro tail-recur (n let-pairs . b)
  80.   ;tail-recur is like named let and defines a loop;
  81.   ;it _requires_ that the loop be always called tail-recursively,
  82.   ;otherwise the results are undefined
  83.   (let* ((x-s (map car let-pairs))
  84.      (y-s (map (lambda (x) (gensym)) x-s))
  85.      (tag (gensym)))
  86.     `(lisp:let ,let-pairs
  87.        (lisp:let ((,n (lambda ,y-s    ;maybe macrolet would be better
  88.             ,@(map
  89.                 (lambda (x y)
  90.                   `(set! ,x ,y))
  91.                 x-s y-s)
  92.             (throw ',tag 'void))))
  93.      (lisp:loop
  94.        (catch ',tag
  95.          (return (begin ,@b))))))))
  96.  
  97. (defmacro recur (name let-pairs . body)
  98.   ;named let
  99.   `(letrec ((,name (lambda ,(map car let-pairs) ,@body)))
  100.      (,name ,@(map cadr let-pairs))))
  101.  
  102. ;let
  103.  
  104. (defmacro let (a . b)
  105.   ;let includes named let;
  106.   ;if named and the name starts with "loop...", then a
  107.   ;tail-recursive loop is assumed
  108.   (cond ((and a (not (symbol? a))) `(lisp:let ,a ,@b))
  109.     ((lisp:let ((s (symbol->string a)))
  110.        (and (>= (length s) 4)
  111.         (char-ci=? (string-ref s 0) #\l)
  112.         (char-ci=? (string-ref s 1) #\o)
  113.         (char-ci=? (string-ref s 2) #\o)
  114.         (char-ci=? (string-ref s 3) #\p)))
  115.      `(tail-recur ,a ,@b))
  116.     (else `(recur ,a ,@b))))
  117.  
  118. ;equivalence predicates
  119.  
  120. (define eqv? eql)
  121. (define equal? equal)
  122.  
  123. ;pairs and lists
  124.  
  125. (define pair? consp)
  126.  
  127. (define set-car! rplaca)
  128. (define set-cdr! rplacd)
  129.  
  130. (define null? null)
  131.  
  132. (define list?                  
  133.   (lambda (s)
  134.     ;tests if s is a proper list;
  135.     ;n.b. this is _not_ cl listp
  136.     (cond ((null? s) #t)
  137.       ((pair? s) (list? (cdr s)))
  138.       (else #f))))
  139.  
  140. (define list-tail subseq) 
  141.  
  142. (define list-ref elt) 
  143.  
  144. (define sequence-set! 
  145.   (lambda (s i v)
  146.     ;sets the i-th element of sequence s to v
  147.     ;not rnrs -- defined only as an auxiliary
  148.     (setf (elt s i) v)))
  149.  
  150. (define memq
  151.   (lambda (x s)
  152.     (lisp:member x s :test eq?)))
  153.  
  154. (define memv lisp:member)
  155.  
  156. (define member
  157.   (lambda (x s)
  158.     (lisp:member x s :test equal?)))
  159.  
  160. (define assq
  161.   (lambda (x s)
  162.     (lisp:assoc x s :test eq?)))
  163.  
  164. (define assv lisp:assoc)
  165.  
  166. (define assoc
  167.   (lambda (x s)
  168.     (lisp:assoc x s :test equal?)))
  169.  
  170. ;symbols
  171.  
  172. (define string->symbol intern)
  173.  
  174. ;numerical operations
  175.  
  176. (define number? numberp)
  177. (define complex? complexp)
  178. (define real? floatp)
  179. (define rational? rationalp)
  180. (define integer? integerp)
  181.  
  182. (define zero? zerop)
  183. (define positive? plusp)
  184. (define negative? minusp)
  185.  
  186. (define odd? oddp)
  187. (define even? evenp)
  188.  
  189. (define quotient (lambda (m n) (truncate (/ m n))))
  190. (define remainder lisp:rem)
  191. (define modulo mod)
  192.  
  193. (define make-rectangular complex)
  194. (define make-polar (lambda (r th) (* r (cis th))))
  195. (define real-part realpart)
  196. (define imag-part imagpart)
  197. (define magnitude abs)
  198. (define angle phase)
  199.  
  200. ;numerical input and output
  201.  
  202. (define number->string
  203.   (lambda (n &optional b)
  204.     (if b (write-to-string n :base b)
  205.     (write-to-string n))))
  206.  
  207. (define string->number
  208.   (lambda (s &optional b)
  209.     (if b (let ((*read-base* b))
  210.         (with-input-from-string (p s)
  211.           (let ((n (lisp:read p)))
  212.         (if (number? n) n #f))))
  213.     (with-input-from-string (p s)
  214.       (let ((n (lisp:read p)))
  215.         (if (number? n) n  #f))))))
  216.  
  217. ;characters
  218.  
  219. (define char? characterp)
  220.  
  221. (define char=? char=)
  222. (define char<? char<)
  223. (define char>? char>)
  224. (define char<=? char<=)
  225. (define char>=? char>=)
  226.  
  227. (define char-ci<? char-lessp)
  228. (define char-ci>? char-greaterp)
  229. (define char-ci<=? char-not-greaterp)
  230. (define char-ci>=? char-not-lessp)
  231.  
  232. (define char-alphabetic? alpha-char-p)
  233. (define char-numeric? digit-char-p)
  234. (define char-whitespace?
  235.   (lambda (c)
  236.     (or (char=? c #\space) (char=? c #\tab)
  237.       (not (graphic-char-p c)))))
  238. (define char-upper-case? upper-case-p)
  239. (define char-lower-case? lower-case-p)
  240.  
  241. (define char->integer char-int)
  242. (define integer->char int-char)
  243.  
  244. ;strings
  245.  
  246. (define string? stringp)
  247.  
  248. (define make-string
  249.   (lambda (n &optional c)
  250.     (lisp:make-string n :initial-element (if c c #\space))))
  251.  
  252. (define string
  253.   (lambda z
  254.     (concatenate 'lisp:string z)))
  255.  
  256. (define string-length length)
  257.  
  258. (define string-set! sequence-set!)
  259.  
  260. (define string=? string=)
  261. (define string<? string<)
  262. (define string>? string>)
  263. (define string<=? string<=)
  264. (define string>=? string>=)
  265.  
  266. (define string-ci=? string-equal)
  267. (define string-ci<? string-lessp)
  268. (define string-ci>? string-greaterp)
  269. (define string-ci<=? string-not-greaterp)
  270. (define string-ci>=? string-not-lessp)
  271.  
  272. (define substring subseq)
  273.  
  274. (define string-append
  275.   (lambda z
  276.     (apply concatenate 'lisp:string z)))
  277.  
  278. (define string->list
  279.   (lambda (s)
  280.     (concatenate 'list s)))
  281.  
  282. (define list->string
  283.   (lambda (s)
  284.     (concatenate 'lisp:string s)))
  285.  
  286. (define string-copy copy-seq) ;seq proc
  287.  
  288. (define string-fill! fill)
  289.  
  290. ;vectors
  291.  
  292. (define vector? vectorp)
  293.  
  294. (define make-vector
  295.   (lambda (n &optional x)
  296.     (make-array (list n) :initial-element x)))
  297.  
  298. (define vector-length length)
  299.  
  300. (define vector-ref elt)
  301.  
  302. (define vector-set! sequence-set!)
  303.  
  304. (define vector->list
  305.   (lambda (v)
  306.     (concatenate 'list v)))    
  307.   
  308. (define list->vector
  309.   (lambda (s)
  310.     (concatenate 'vector s)))
  311.  
  312. (define vector-fill! fill)
  313.  
  314. ;control features
  315.  
  316. (define procedure? functionp)
  317.  
  318. (define for-each mapc)
  319.  
  320. (define call-with-current-continuation
  321.   (lambda (r)
  322.     ;n.b. continuations are downward only
  323.     (let ((tag (gensym)))
  324.       (catch tag
  325.     (r (lambda (v) (throw tag v)))))))
  326.  
  327. ;ports
  328.  
  329. (define call-with-input-file
  330.   (lambda (f pr)
  331.     (with-open-file (p f :direction :input)
  332.       (pr p))))
  333.  
  334. (define call-with-output-file
  335.   (lambda (f pr)
  336.     (with-open-file (p f :direction :output)
  337.       (pr p))))
  338.  
  339. (define input-port? input-stream-p)
  340. (define output-port? output-stream-p)
  341.  
  342. (define current-input-port (lambda () *standard-input*))
  343. (define current-output-port (lambda () *standard-output*))
  344.  
  345. (define with-input-from-file
  346.   (lambda (f th)
  347.     (call-with-input-file f
  348.       (lambda (p)
  349.     (let ((*standard-input* p)) ;fluid-let
  350.       (th))))))
  351.  
  352. (define with-output-to-file
  353.   (lambda (f th)
  354.     (call-with-output-file f
  355.       (lambda (p)
  356.     (let ((*standard-output* p)) ;fluid-let
  357.       (th))))))
  358.  
  359. (define open-input-file
  360.   (lambda (f)
  361.     (open f :direction :input)))
  362.  
  363. (define open-output-file
  364.   (lambda (f)
  365.     (open f :direction :output)))
  366.  
  367. (define close-input-port close)
  368. (define close-output-port close)
  369.  
  370. ;input
  371.  
  372. (define read
  373.   (lambda (&optional p)
  374.     (lisp:read p #f :end-of-file)))
  375.  
  376. (define read-char
  377.   (lambda (&optional p)
  378.     (lisp:read-char p #f :end-of-file)))
  379.  
  380. (define peek-char
  381.   (lambda (&optional p)
  382.     (lisp:peek-char #f p #f :end-of-file)))
  383.  
  384. (define eof-object?
  385.   (lambda (v)
  386.     (eq? v :end-of-file)))
  387.  
  388. (define char-ready?
  389.   (lambda (&optional p)
  390.     (let ((c (read-char-no-hang p #f #f)))
  391.       (if c (begin (unread-char c i) #t)
  392.       #f))))
  393.  
  394. ;output
  395.  
  396. (define write prin1)
  397.  
  398. (define display princ)
  399.  
  400. (define newline terpri)
  401.  
  402. ;system interface
  403.  
  404. (define transcript-on dribble)
  405. (define transcript-off dribble)
  406.